home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / faq-s.zip / FILEXFER.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-04  |  68KB  |  2,379 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
  2. {$M 65520,0,4096 }
  3.  
  4. unit filexfer;
  5.  
  6. interface
  7.  
  8. uses crt,dos,overlay,configur,
  9.      gentypes,configrt,modem,statret,gensubs,subs1,subs2,windows,
  10.      userret,mainr1,mainr2,overret1,protocol,mainmenu,subs3,textret;
  11.  
  12. procedure udsection;
  13. var cn:byte;
  14. implementation
  15.  
  16. procedure filemenu;
  17. begin
  18. filemenu;
  19. end;
  20.  
  21. procedure udsection;
  22. {$I file2}
  23.  
  24.   procedure listfile (n:integer; extended:boolean); forward;
  25.   procedure listfiles (extended:boolean); forward;
  26.   function capfir(inString:STRING):STRING; forward;
  27.  
  28.   function findprot(rors,prot:char):boolean;
  29.   var bonzo:file of protorec; sod:boolean;
  30.  
  31.   begin
  32.        sod:=false;
  33.        assign(bonzo,bbsdatadir+'PROT'+upcase(rors)+'.CFG');
  34.        reset(bonzo);
  35.        while not(eof(bonzo)) and not(sod) do
  36.              begin
  37.                   read(bonzo,protrec);
  38.                   if protrec.letter=upcase(prot) then sod:=true;
  39.              end;
  40.        findprot:=sod;
  41.        prprog:=protrec.progname;
  42.        prcomm:=protrec.commfmt;
  43.        prdesc:=protrec.desc;
  44.        close(bonzo);
  45.   end;
  46.  
  47. procedure xtendedlist;
  48. var num:integer;
  49.     ud:udrec;
  50. begin
  51.   writestr ('[Enter File Number to List Extended Descrip]: *');
  52.   num:=valu(input);
  53.   if num>numuds then exit;
  54.   if num<1 then exit;
  55.   seekudfile (num);
  56.   read (udfile,ud);
  57.   writeln (^U'═════════════════════════════════════════════════════════════════════════════');
  58.   writeln (^S,ud.extdesc);
  59.   writeln (^U'═════════════════════════════════════════════════════════════════════════════');
  60. end;
  61.  
  62. procedure whoup;
  63.  
  64. procedure toplinewho;
  65.  begin
  66.   if asciigraphics in urec.config then begin
  67.   writeln('┌───┬───────────────┬──────────────────────────────┬────────┬────────────┐');
  68.   writeln('│ '^S'#'^R' │   '^S'Filename'^R'    │        '^S'Uploaded by'^R'           │ '^S'Cost  '^R' │ '+
  69.   ^S'Downloaded'^R' │');
  70.   writeln('├───┼───────────────┼──────────────────────────────┼────────┼────────────┤') end else begin
  71.   writeln('+---+---------------+------------------------------+--------+------------+');
  72.   writeln('| '^S'#'^R' |   '^S'Filename'^R'    |        '^S'Uploaded by'^R'           | '^S'Cost  '^R' | '+
  73.           ^S'Downloaded'^R' |');
  74.   writeln('|---|---------------|------------------------------|--------|------------|');
  75.    end;
  76.   end;
  77.  
  78. procedure botlinewho;
  79.  begin
  80.   if asciigraphics in urec.config then
  81.   writeln(^R'└───┴───────────────┴──────────────────────────────┴────────┴────────────┘') else
  82.   writeln(^R'+---+---------------+------------------------------+--------+------------+');
  83.  end;
  84.   var ud :udrec;
  85.       cnt:integer;
  86.   begin
  87.   toplinewho;
  88.   for cnt:=1 to numuds do
  89.    begin
  90.      seekudfile (cnt);
  91.      read (udfile,ud);
  92.      if asciigraphics in urec.config then begin
  93.      write (^R'│ '^S,strr(cnt));
  94.      spacelen(2-length(strr(cnt)));
  95.      write (^R'│ '^S,ud.filename);
  96.      spacelen(14-length(ud.filename));
  97.      write (^R'│ '^S,ud.sentby);
  98.      spacelen(29-length(ud.sentby));
  99.      write (^R'│ '^S,ud.points);
  100.     spacelen(7-length(strr(ud.points)));
  101.      write (^R'│ '^S,ud.downloaded);
  102.      spacelen(11-length(strr(ud.downloaded)));
  103.      writeln (^R'│');
  104.     end else begin
  105.      write (^R'| '^S,strr(cnt));
  106.      spacelen(2-length(strr(cnt)));
  107.      write (^R'| '^S,ud.filename);
  108.      spacelen(14-length(ud.filename));
  109.      write (^R'| '^S,ud.sentby);
  110.      spacelen(29-length(ud.sentby));
  111.      write (^R'| '^S,ud.points);
  112.     spacelen(7-length(strr(ud.points)));
  113.      write (^R'| '^S,ud.downloaded);
  114.      spacelen(11-length(strr(ud.downloaded)));
  115.      writeln (^R'|');
  116.     end;
  117.    end;
  118.   botlinewho;
  119.   end;
  120.  
  121.   function searchforfile (f:sstr):integer;
  122.   var ud:udrec;
  123.       cnt:integer;
  124.   begin
  125.     for cnt:=1 to numuds do begin
  126.       seekudfile (cnt);
  127.       read (udfile,ud);
  128.       if match(ud.filename,f) then begin
  129.         searchforfile:=cnt;
  130.         exit
  131.       end
  132.     end;
  133.     searchforfile:=0
  134.   end;
  135.  
  136.   function getfilenum (t:mstr):integer;
  137.   var n,s:integer;
  138.   begin
  139.     getfilenum:=0;
  140.     if length(input)>1 then input:=copy(input,2,255) else
  141.       repeat
  142.         writestr ('File Name/Number to '+t+' [?/List]:');
  143.         if hungupon or (length(input)=0) then exit;
  144.         if input='?' then begin
  145.           listfiles (false);
  146.           input:=''
  147.         end
  148.       until input<>'';
  149.     val (input,n,s);
  150.     if s<>0 then begin
  151.       n:=searchforfile(input);
  152.       if n=0 then begin
  153.         writeln ('File not found.');
  154.         exit
  155.       end
  156.     end;
  157.     if (n<1) or (n>numuds)
  158.       then writeln ('File number out of range!')
  159.       else getfilenum:=n
  160.   end;
  161.  
  162.   const beenaborted:boolean=false;
  163.  
  164.   function aborted:boolean;
  165.   begin
  166.     if beenaborted then begin
  167.       aborted:=true;
  168.       exit
  169.     end;
  170.     aborted:=xpressed or hungupon;
  171.     if xpressed then begin
  172.       beenaborted:=true;
  173.       writeln (^B'File newscan aborted!')
  174.     end
  175.   end;
  176.  
  177.   procedure getstring (t:lstr; var m);
  178.   var q:lstr absolute m;
  179.       mm:lstr;
  180.   begin
  181.     writeln ('Old ',t,': ',q);
  182.     writestr ('Enter new '+t+' [CR/no change]: &');
  183.     mm:=input;
  184.     if length(mm)<>0 then q:=mm;
  185.     writeln
  186.   end;
  187.  
  188.   procedure getstringgg (t:lstr; var m);
  189.   var q:lstr absolute m;
  190.       mm:lstr;
  191.   begin
  192.     writeln ('Old ',t,': ',q);
  193.     writestr ('Enter new '+t+' [CR/no change, "!" for null]:');
  194.     mm:=input;
  195.     if length(mm)<>0 then q:=mm;
  196.     if mm='!' then q:='';
  197.     writeln
  198.   end;
  199.  
  200.   procedure getint (t:lstr; var i:integer);
  201.   var s:sstr;
  202.   begin
  203.     s:=strr(i);
  204.     getstring (t,s);
  205.     i:=valu(s)
  206.   end;
  207.  
  208.   procedure getboo (t:lstr; var b:boolean);
  209.   var s:sstr;
  210.   begin
  211.     s:=yesno (b);
  212.     getstring (t,s);
  213.     b:=upcase(s[1])='Y'
  214.   end;
  215.  
  216.   procedure removefile (n:integer);
  217.   var cnt:integer;
  218.   begin
  219.     for cnt:=n to numuds-1 do begin
  220.       seekudfile (cnt+1);
  221.       read (udfile,ud);
  222.       seekudfile (cnt);
  223.       write (udfile,ud)
  224.     end;
  225.     seekudfile (numuds);
  226.     truncate (udfile)
  227.   end;
  228.  
  229.   procedure displayfile (var ffinfo:searchrec);
  230.   var a:integer;
  231.   begin
  232.     a:=ffinfo.attr;
  233.     if (a and 8)=8 then exit;
  234.     tab (^S+ffinfo.name,13);
  235.     if (a and 16)=16
  236.       then write (^S'Directory')
  237.       else write (^S,ffinfo.size);
  238.     if (a and 1)=1 then write (^P' [',^S,'read-only',^P,']'^R);
  239.     if (a and 2)=2 then write (^P' [',^S,'hidden',^P,']'^R);
  240.     if (a and 4)=4 then write (^P' [',^S,'system',^P,']'^R);
  241.     writeln
  242.   end;
  243.  
  244.   function defaultdrive:byte;
  245.   var r:registers;
  246.   begin
  247.     r.ah:=$19;
  248.     intr ($21,r);
  249.     defaultdrive:=r.al+1
  250.   end;
  251.  
  252.   procedure directory;
  253.   var r:registers;
  254.       ffinfo:searchrec;
  255.       tpath:anystr;
  256.       b:byte;
  257.       cnt:integer;
  258.   begin
  259.     { getdir (defaultdrive,tpath); }
  260.     tpath:=area.xmodemdir;
  261.     if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
  262.     tpath:=tpath+'*.*';
  263.     writestr ('Path/Wildcard [CR/'+tpath+']:');
  264.     writeln (^M);
  265.     if length(input)<>0 then tpath:=input;
  266.     writelog (16,10,tpath);
  267.     findfirst (chr(defaultdrive+64)+':\*.*',8,ffinfo);
  268.     if doserror<>0
  269.       then writeln ('No volume label'^M)
  270.       else writeln ('Volume label: ',ffinfo.name,^M);
  271.     findfirst (tpath,$17,ffinfo);
  272.     if doserror<>0 then writeln ('No files found.') else begin
  273.       cnt:=0;
  274.       while doserror=0 do begin
  275.         cnt:=cnt+1;
  276.         if not break then displayfile (ffinfo);
  277.         findnext (ffinfo)
  278.       end;
  279.       writeln (^B^M'Total Files: ',cnt)
  280.     end;
  281.     write ('Free Disk Space: ');
  282.     writefreespace (tpath)
  283.   end;
  284.  
  285.   procedure listarchive (int:integer);
  286.   var n:integer;
  287.       ud:udrec;
  288.       f:file of byte;
  289.       fname:lstr;
  290.       b,p:byte;
  291.       sg:boolean;
  292.       size:longint;
  293.       sussuh:sstr;
  294.       ock:char;
  295.  
  296.     function getsize:longint;
  297.     var x:longint;
  298.         b:array [1..4] of byte absolute x;
  299.         cnt:integer;
  300.     begin
  301.       for cnt:=1 to 4 do read (f,b[cnt]);
  302.       getsize:=x
  303.     end;
  304.  
  305.     procedure badarchive;
  306.     begin
  307.       writeln (^M'That file isn''t an archive!');
  308.       close (f);
  309.       exit
  310.     end;
  311.  
  312.   begin
  313.     if nofiles then exit;
  314.     if int<1 then begin
  315.      n:=getfilenum('List');
  316.      if n=0 then exit;
  317.     end else n:=int;
  318.     seekudfile (n);
  319.     read (udfile,ud);
  320.     fname:=getfname(ud.path,ud.filename);
  321.     assign (f,fname);
  322.     reset (f);
  323.     iocode:=ioresult;
  324.     if iocode<>0 then begin
  325.       fileerror ('LISTARCHIVE',fname);
  326.       exit
  327.     end;
  328.     if filesize(f)<32 then begin
  329.       badarchive;
  330.       exit
  331.     end;
  332.     p:=pos ('.',ud.filename);
  333.     sussuh:=copy (ud.filename,p+1,3);
  334.     sussuh:=upstring(sussuh);
  335.     close (f);
  336.     writehdr ('ARC/PAK/ZIP File List');
  337.     writeln;
  338.     write (^R'Archive Type: '^S);
  339.     if sussuh='ARC' then writeln ('PKARC/PKPAK') else
  340.     if sussuh='PAK' then writeln ('PAK') else
  341.     if sussuh='ZIP' then writeln ('PKZIP') else
  342.     if sussuh='LZH' then writeln ('LHARC') else
  343.     if (sussuh<>'ARC') and (sussuh<>'PAK') and (sussuh<>'ZIP') and
  344.        (sussuh<>'LZH') then begin
  345.      writeln ('Unknown!');
  346.      writeln;
  347.      writeln (^R'This file does not seem to be an archive of the ARC, PAK, or ZIP type.');
  348.      writestr ('Would you care to manually select the archive type [y/n]: *');
  349.      if yes then repeat
  350.       writeln (^R'[1]: PKARC/PKPAK');
  351.       writeln (^R'[2]: PAK');
  352.       writeln (^R'[3]: PKZIP');
  353.       writeln (^R'[4]: LHARC');
  354.       writeln (^R'[Q]: Quit');
  355.       writeln;
  356.       writestr ('Selection:');
  357.       ock:=upcase(input[1]);
  358.       if ock='1' then sussuh:='ARC' else
  359.       if ock='2' then sussuh:='PAK' else
  360.       if ock='3' then sussuh:='ZIP' else
  361.       if ock='4' then sussuh:='LZH';
  362.      until ock in ['Q','1','2','3'];
  363.     end;
  364.     writeln;
  365.     writeln ('Please hold.');
  366.     writeln;
  367.     if sussuh='ARC' then arcview (fname) else
  368.     if sussuh='PAK' then pakview (fname) else
  369.     if sussuh='ZIP' then zipview (fname) else
  370.     if sussuh='LZH' then lharcview (fname);
  371.   end;
  372.  
  373. procedure requestfile;
  374. var t:text;
  375.     me:message;
  376.     m:mailrec;
  377. begin
  378.   if hungupon then exit;
  379.   writestr (^M^J+'Filename to Request: *');
  380.   if length(input)=0 then exit;
  381.   input:=upstring(input);
  382.   writeln (^M^J+'Enter a Message regarding the File Request:');
  383.   delay (1000);
  384.   titlestr:='File Request: '+input;
  385.   sendstr:='Sysop';
  386.   m.line:=editor (me,false,'File Request: '+input);
  387.   sendstr:='';
  388.   if m.line<0 then exit;
  389.   m.anon:=false;
  390.   m.title:=titlestr;
  391.   m.sentby:=unam;
  392.   m.when:=now;
  393.   addfeedback (m);
  394. end;
  395.  
  396.   procedure download (autoselect:integer; checktheok:boolean);
  397.   var totaltime:sstr;
  398.       num,fsize,actualsize,mins,secs,i,b,dsziactualsize,realtime:integer;
  399.       ud:udrec;
  400.       fname,faqrulez,protop,byteblok:lstr;
  401.       ymodem,okselect:boolean;
  402.       f:file;
  403.       m:sstr;
  404.       extrnproto:char; resp:char; byewhendone:boolean;
  405.       n:text;
  406.       ok:boolean;
  407.   begin
  408.     if not allowxfer then exit;
  409.     if nofiles then exit;
  410.     if percent (urec.uploads,urec.downloads)<udratio then begin
  411.       writeln ('Your Upload/Download ratio is too low!   Upload some files!');
  412.       exit;
  413.     end;
  414.     if useqr then begin
  415.      calcqr;
  416.      if (qr<qrlimit) and (ulvl<qrexempt) then begin
  417.       writeln ('Your Quality Rating is '^S+strr(qr)+^R'.');
  418.       writeln ('That exceeds the limit of '^S+strr(qrlimit)+^R'!');
  419.       writeln ('You must get a better QR before you can download.');
  420.       exit;
  421.      end;
  422.      end;
  423.     if checktheok then begin
  424.     if (area.download=false) then begin
  425.      writeln;
  426.      writeln ('Sorry, downloading is not allowed from this area!');
  427.      writeln;
  428.      exit;
  429.     end;
  430.     end;
  431.     if autoselect=0
  432.       then num:=getfilenum('download')
  433.       else num:=autoselect;
  434.     if num=0 then exit;
  435.     writeln;
  436.     seekudfile (num);
  437.     read (udfile,ud);
  438.     ok:=checkok (ud);
  439.     if not ok then exit;
  440.     ymodem:=false;
  441.     extrnproto:=' ';
  442.     listprotocols(0);
  443.     if hungupon then exit;
  444.     writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
  445.     if hungupon then exit;
  446.     if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
  447.     if upstring (input)='Q' then exit;
  448.     okselect:=findprot('S',extrnproto);
  449.     if not okselect then exit;
  450.  
  451.     fname:=getfname(ud.path,ud.filename);
  452.  
  453.     assign (f,fname);
  454.     reset (f);
  455.     iocode:=ioresult;
  456.     if iocode<>0 then
  457.       begin
  458.       writeln; writeln('ERROR: Unable to locate file ',fname);
  459.         fileerror ('DOWNLOAD',fname);
  460.         exit
  461.       end;
  462.  
  463.     fsize:=filesize(f);
  464.     actualsize:=fsize;
  465.     close (f);
  466.     totaltime:=minstr(fsize);
  467.     mins:=valu(copy(totaltime,1,pos(':',totaltime)-1));
  468.     secs:=valu(copy(totaltime,pos(':',totaltime)+1,2));
  469.     realtime:=mins;
  470.     if secs<>0 then realtime:=mins+(secs div 60);
  471.     if mins=0 then mins:=1;
  472.     if ((mins>timeleft) and (not sponsoron)) then begin
  473.       writestr ('Sorry, you don''t have enough time left!');
  474.       mins:=-5;
  475.       exit
  476.     end;
  477.     if (mins-5>timetillevent) then begin
  478.       writestr ('Sorry, the timed event is coming up too soon!');
  479.       mins:=-5;
  480.       exit
  481.     end;
  482. writeln;
  483.  
  484.         askaboutbye;
  485.     if answer='A' then exit;
  486.     wipedszlog;
  487.  
  488.     if (ansigraphics in urec.config) then write (#27+'[2J') else write (^L);
  489.     if asciigraphics in urec.config then begin
  490.     writeln (^B);
  491.     writeln (^R'┌─────────────────────────────────────────┐');
  492.     write (^R'│ '^S'Filename:       '^S);
  493.     tab (ud.filename,24);
  494.     writeln (^R'│');
  495.     write (^R'│ '^S'Uploaded by:    '^S);
  496.     tab (ud.sentby,24);
  497.     writeln (^R'│');
  498.     write (^R'│ '^S'Downloaded:     '^S);
  499.     faqrulez:='';
  500.     faqrulez:=strr(ud.downloaded)+' time';
  501.     if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
  502.     tab (faqrulez,24);
  503.     writeln (^R'│');
  504.     if ymodem then fsize:=(fsize+7) div 8;
  505.     if fsize=0 then fsize:=1;
  506.     write (^R'│ '^S'Bytes to send:  '^S);
  507.     byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
  508.     tab (byteblok,26);
  509.     writeln (^R'│');
  510.     write (^R'│ '^S'Transfer Time:  '^S);
  511.     tab (totaltime,24);
  512.     writeln (^R'│');
  513.     writeln (^R'├─────────────────────────────────────────┤');
  514.     writeln (^R'│    Hit ['^S'Ctrl X'^R'] a few times to Abort    │');
  515.     writeln (^R'└─────────────────────────────────────────┘');
  516.     writeln;
  517.     end else begin
  518.     writeln (^B);
  519.     writeln (^R'+-----------------------------------------+');
  520.     write (^R'| '^S'Filename:       '^S);
  521.     tab (ud.filename,24);
  522.     writeln (^R'|');
  523.     write (^R'| '^S'Uploaded by:    '^S);
  524.     tab (ud.sentby,24);
  525.     writeln (^R'|');
  526.     write (^R'| '^S'Downloaded:     '^S);
  527.     faqrulez:='';
  528.     faqrulez:=strr(ud.downloaded)+' time';
  529.     if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
  530.     tab (faqrulez,24);
  531.     writeln (^R'|');
  532.     if ymodem then fsize:=(fsize+7) div 8;
  533.     if fsize=0 then fsize:=1;
  534.     write (^R'| '^S'Bytes to send:  '^S);
  535.     byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
  536.     tab (byteblok,26);
  537.     writeln (^R'|');
  538.     write (^R'| '^S'Transfer Time:  '^S);
  539.     tab (totaltime,24);
  540.     writeln (^R'|');
  541.     writeln (^R'|-----------------------------------------|');
  542.     writeln (^R'|    Hit ['^S'Ctrl X'^R'] a few times to Abort    |');
  543.     writeln (^R'+-----------------------------------------+');
  544.     writeln;
  545.     end;
  546.       b:=doext ('S',extrnproto,ud.path,ud.filename,baudrate,usecom);
  547.       if b<>0 then b:=2;
  548.       modeminlock:=false;
  549.       beepbeep (b);
  550.  
  551.       xtype:=checkdszlog (ud.filename);
  552.       if (upcase(xtype)='Q') then
  553.        begin
  554.        possiblelzm (ud.points);
  555.        b:=2;
  556.        end;
  557.       if (b=0) or (b=1) then begin
  558.       writelog (15,1,fname);
  559.       writeln;
  560.       clrscr;
  561.       ud.downloaded:=ud.downloaded+1;
  562.       urec.downloads:=urec.downloads+1;
  563.       urec.udpoints:=urec.udpoints-ud.points;
  564.       urec.downk:=urec.downk+ud.filesize;
  565.       seekudfile (num);
  566.       write (udfile,ud);
  567.       showhisstats;
  568.       writeurec;
  569.    if answer='H' then laterdays
  570.     end;
  571.   end;
  572.  
  573.   procedure typefile;
  574.   var num:integer;
  575.       ud:udrec;
  576.       fname:lstr;
  577.       f:text;
  578.       k:char;
  579.   begin
  580.     if nofiles then exit;
  581.     num:=getfilenum('type');
  582.     if num=0 then exit;
  583.     writeln;
  584.     seekudfile (num);
  585.     read (udfile,ud);
  586.     if (not sponsoron) and (ud.points>urec.udpoints) then begin
  587.       writeln ('Sorry, that file requires ',ud.points,' points.');
  588.       exit
  589.     end;
  590.     if (ud.newfile) and (not sponsoron) then begin
  591.       writeln ('Sorry, that is a new file and must be validated.');
  592.       exit
  593.     end;
  594.     if (ud.specialfile) and (not sponsoron) then begin
  595.       writeln ('Sorry, downloading that file requires special permission.');
  596.       exit
  597.     end;
  598.     if (length(ud.dlpw)>0) and (filepw) then begin
  599.      writeln;
  600.      writestr ('File Password:');
  601.      if length(input)=0 then exit else
  602.      if not match(input,ud.dlpw) then exit;
  603.     end;
  604.     if tempsysop then begin
  605.       ulvl:=regularlevel;
  606.       tempsysop:=false;
  607.       writeurec;
  608.       bottomline
  609.     end;
  610.     fname:=getfname(ud.path,ud.filename);
  611.     assign (f,fname);
  612.     reset (f);
  613.     iocode:=ioresult;
  614.     if iocode<>0 then
  615.       begin
  616.         fileerror ('TYPEFILE',fname);
  617.         exit
  618.       end;
  619.     writeln (^B^M'Filename:       '^S,ud.filename);
  620.     writeln ('Uploaded by:    '^S,ud.sentby);
  621.     if (ud.points>0) and (not sponsoron) then begin
  622.       write (^B^M'NOTE: When the transfer begins, you ',
  623.                ^M'      will be charged ',ud.points,' point');
  624.       if ud.points<>1 then write ('s');
  625.       writeln ('!')
  626.     end;
  627.     writeln (^B^M'Press any key to begin the transfer,',
  628.                ^M'or [Ctrl-X] to abort.'^M);
  629.     k:=waitforchar;
  630.     if (k=^X) or (upcase(k)='X') then begin
  631.       textclose (f);
  632.       writeln (^B^M'Aborted!');
  633.       exit
  634.     end;
  635.     while not (eof(f) or break) do begin
  636.       read (f,k);
  637.       if k=^M then writeln else if k<>^J then write (k)
  638.     end;
  639.     textclose (f);
  640.     if (ud.points>0) and (not sponsoron) then begin
  641.       urec.udpoints:=urec.udpoints-ud.points;
  642.       writeln (^B'You now have ',
  643.                numthings (urec.udpoints,'point','points'),'.')
  644.     end;
  645.     writeurec
  646.   end;
  647.  
  648.   procedure processfile(fn,todir:lstr);
  649.   var fn1:lstr; util:integer;
  650.   begin
  651.     write(^P' - Processing. ');
  652.     util:=pos('.',fn);
  653.     if util=0 then fn1:=fn else fn1:=copy(fn,1,util-1);
  654.         if exist ('PROCESS.BAT') then
  655. exec(getenv('COMSPEC'),' /C PROCESS.BAT '+fn+' '+todir+' '+fn1);
  656.   end;
  657.  
  658.  
  659.   procedure upload;
  660.   var ud:udrec;
  661.       ok,crcmode,ymodem,extdone,cool:boolean;
  662.       i,b,granted,ultime:integer;
  663.       dah:real;
  664.       fn,protop:lstr;
  665.       extrnproto:char;
  666.       e1,e2,e3:lstr;
  667.       f:file;
  668.       time:string;
  669.   var process:boolean; dir1:lstr;
  670.  
  671.   procedure acceptfile(fname:lstr);
  672.   var process:boolean; dir1,extend:lstr; f1,f2:text; fn1,fn2:mstr; fn3:lstr;
  673.   begin
  674.     process:=true;
  675.     dir1:=copy(area.xmodemdir,1,length(area.xmodemdir)-1);
  676.     extend:=copy(fname,length(fname)-3,4);
  677.     extend:=upstring(extend);
  678.     write(^R'Received File: '^S+fname);
  679.     fn1:=faqdir+'PROCNAME.'+strr(conn);
  680.         fn2:=faqdir+'PROCMSG.'+strr(conn);
  681.     assign(f1,fn1); assign(f2,fn2);
  682.     if exist(fn1) then erase(f1);
  683.     if exist(fn2) then erase(f2);
  684.     if process then processfile(fname,extend);
  685.     if exist(fn1) then begin
  686.                 reset(f1);
  687.                 readln(f1,fn3);
  688.                 close(f1);
  689.                 ud.filename:=fn3;
  690.                 fname:=fn3;
  691.                end;
  692.     if exist(fn2) then begin
  693.                 reset(f2);
  694.                 readln(f2,fn3);
  695.                 close(f2);
  696.                 write(^S'  '+fn3+'. ');
  697.                end;
  698.     if not exist(xferdir+fname) then exit;
  699.  
  700.     writeln(^P'Posting.');
  701. exec(getenv('COMSPEC'),' /C copy '+xferdir+fname+' '+dir1+' >nul');
  702. exec(getenv('COMSPEC'),' /C del '+xferdir+fname+' >nul');
  703.    end;
  704.  
  705.    procedure getextras;
  706.    var r:registers; ffinfo:searchrec;
  707.        tpath:anystr; b:byte; cnt:integer; mm:text; fname:lstr;
  708.  
  709.    begin
  710.     writeln; writeln(^R'Checking Upload Discrepancy.');
  711.     writeln;
  712.     tpath:=xferdir+'*.*'; cnt:=0;
  713.     findfirst (tpath,$17,ffinfo);
  714.  
  715. if doserror<>0 then begin
  716.             writeln('File not received. [Upload Aborted]');
  717.             exit;
  718.             end;
  719.  
  720.           if ffinfo.name[1]<>'.' then begin
  721.                     fname:=ffinfo.name;
  722.           if answer<>'H' then begin
  723.             writeln;
  724.                 writestr(^R'Describe file '^S+ffinfo.name+^R+': *');
  725.             ud.programname:=input;
  726.             writestr(^R'Disk Number: *');
  727.             ud.disknum:=valu(input);
  728.                         if ud.disknum<1 then ud.disknum:=1;
  729.             writestr(^R'Total # of disks: *');
  730.             ud.totaldisk:=valu(input);
  731.                         if ud.totaldisk<1 then ud.totaldisk:=1;
  732.             writestr(^R'Download P/W for file: *');
  733.             ud.dlpw:=input;
  734.             end else begin
  735.             ud.programname:='Upload with no description.';
  736.                         ud.disknum:=1;
  737.                         ud.totaldisk:=1;
  738.             ud.dlpw:='';
  739.                         ud.private:='';
  740.             end;
  741.           acceptfile(fname);
  742.       end;
  743. end;
  744.  
  745.   var pointv:longint;
  746.           pp:integer;
  747.   begin
  748.     if not allowxfer then exit;
  749.     if timetillevent<30 then begin
  750.       writestr (
  751.    'Sorry, uploads are not allowed within one half hour of the timed event!');
  752.       exit
  753.     end;
  754.     if area.upload=false then begin
  755.      writeln;
  756.      writeln ('Sorry, uploading is not allowed into this area!');
  757.      writeln;
  758.      exit;
  759.     end;
  760.     ok:=false;
  761.     write ('Free Disk Space: ');
  762.     writefreespace (area.xmodemdir);
  763.     writeln;
  764.     repeat
  765.      writestr ('Upload Filename: *');
  766.      if length(input)=0 then exit;
  767.      if not validfname(input) then begin
  768.       writeln ('Invalid filename!');
  769.       exit
  770.      end;
  771.      ud.filename:=upstring(input);
  772.      ud.path:=area.xmodemdir;
  773.      fn:=getfname(ud.path,ud.filename);
  774.      if hungupon then exit;
  775.      if exist(fn) then writeln ('File already exists!') else ok:=true
  776.     until ok;
  777.     if filepw then begin
  778.      buflen:=30;
  779.      writestr ('File Password [CR/None]: &');
  780.      if length(input)=0 then ud.dlpw:='' else ud.dlpw:=input;
  781.     end else
  782.     ud.dlpw:='';
  783.     writestr ('Private for: &');
  784.     if length(input)=0 then ud.private:='' else ud.private:=input;
  785.     buflen:=27;
  786.     writestr ('Program Description: &');
  787.     ud.programname:=input;
  788.     buflen:=2;
  789.     writestr ('Disk Number: &');
  790.     ud.disknum:=valu(input);
  791.     if ud.disknum<1 then ud.disknum:=1;
  792.     buflen:=2;
  793.     writestr ('Total Disks: &');
  794.     ud.totaldisk:=valu(input);
  795.     if ud.totaldisk<1 then ud.totaldisk:=1;
  796.     buflen:=45;
  797.     ud.extdesc:=getextdesc;
  798.     buflen:=40;
  799.     if ups>32765 then ups:=0;
  800.     inc(ups);
  801.     ud.sentby:=unam;
  802.     ud.when:=now;
  803.     ud.whenrated:=now;
  804.     ud.points:=0;
  805.     ud.downloaded:=0;
  806.         ud.newfile:=true;
  807.     ud.specialfile:=false;
  808.     crcmode:=false;
  809.     ymodem:=false;
  810.     extrnproto:='N';
  811.     listprotocols (1);
  812.     if hungupon then exit;
  813.     writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
  814.     if hungupon then exit;
  815.     if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
  816.     if upstring (input)='Q' then exit;
  817.     cool:=findprot('R',extrnproto);
  818.     if not cool then exit;
  819.  
  820.     askaboutbye;
  821.     if answer='A' then exit;
  822.  
  823.     ultime:=timer;
  824.     if tempsysop then begin
  825.       ulvl:=regularlevel;
  826.       tempsysop:=false;
  827.       writeurec;
  828.       bottomline
  829.     end;
  830.       begin
  831.       wipedszlog;
  832.       b:=doext ('R',extrnproto,xferdir,ud.filename,baudrate,usecom);
  833.       modeminlock:=false;
  834.       modemoutlock:=false;
  835.       beepbeep (b)
  836.     end;
  837.       xtype:=checkdszlog (ud.filename);
  838.     if b>=1 then begin
  839.       writeln;
  840.       clrscr;
  841.       fn:=getfname (xferdir,ud.filename);
  842.       if exist (fn) then begin
  843.        assign(f,fn);
  844.        erase (f);
  845.       end;
  846.      exit;
  847.     end;
  848.     if b=0 then begin
  849.         writeln;
  850.         clrscr;
  851.         acceptfile(ud.filename);
  852.     getfsize(ud);
  853.        {pointv:=pointvalue;
  854.         pointv:=pointv*1000;}
  855.         if (autovalidate) and (pointvalue>0) then begin
  856.         ud.points:=(ud.filesize div pointvalue div 1024);
  857.         writeln (^R'Granting '+ud.filename+' '+strr(ud.points)+^R' points.');
  858.         end else ud.points:=0;
  859.         pp:=ud.points*uploadfactor;
  860.         writeln (^R'Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
  861.         ud.newfile:=false;
  862.         urec.udpoints:=urec.udpoints+pp;
  863.         addfile(ud);
  864.     inc(urec.uploads);
  865.     urec.upk:=urec.upk+ud.filesize;
  866.     newuploads:=newuploads+1;
  867.     writeurec;
  868.     end;
  869.      if (ulpercent>0) and (not aborted) then begin
  870.     { endtime:=timer;
  871.       if endtime<starttime then endtime:=endtime+1440;
  872.       xfertimecredit:=(endtime-starttime);
  873.       writeln;
  874.       granted:=xfertimecredit;
  875.       granted:=granted*(ulpercent div 100);
  876.       settimeleft (timeleft+granted);
  877.       str (timeleft,time); }
  878.       ultime:=timer-ultime;
  879.       if ultime<0 then ultime:=ultime+1440;
  880.       granted:=ultime*(ulpercent div 100);
  881.       writeln (^R'Granting upload time compensation of '^S+strr(granted)+^R' minutes.');
  882.       urec.timetoday:=urec.timetoday+granted;
  883.       writeurec;
  884.      end;
  885.     avrcps;
  886.     if zipcomment then begin
  887.     addcomment (area.xmodemdir,ud.filename);
  888.     end;
  889.     showhisstats;
  890.     if answer='H' then laterdays;
  891.   end;
  892.  
  893.   procedure searchfile;
  894.   var cnt,cntt,totalcnt:integer;
  895.       searchall:boolean;
  896.       wildcard:sstr;
  897.       a:arearec;
  898.       stext:anystr;
  899.  
  900.     procedure searcharea;
  901.     var cnt,knt:integer; needbox:boolean;
  902.         u:udrec;
  903.     begin
  904.       knt:=0; needbox:=true;
  905.       for cnt:=1 to numuds do begin
  906.         seekudfile (cnt);
  907.         read (udfile,u);
  908.     if wildcardmatch (wildcard,u.filename) then begin
  909.       if needbox then begin
  910.                                 writeln;
  911.                 topfileline;
  912.                 needbox:=false;
  913.               end;
  914.           listfile (cnt,false);
  915.       inc(knt); inc(totalcnt);
  916.         end;
  917.         if xpressed then exit
  918.       end;
  919.       if not needbox then begin
  920.             bottomfileline;
  921.             writeln(^S+strr(knt)+^P' file(s) found.'^R);
  922.             writeln;
  923.             end;
  924.     end;
  925.  
  926.     procedure totalmatch;
  927.     begin
  928.     writeln; writeln(^S+strr(totalcnt)+^P+' matches found.');
  929.     end;
  930.  
  931.     procedure searchareatext (t:anystr);
  932.     var cnt,knt:integer;
  933.     u:udrec;
  934.     b,needbox:boolean;
  935.     begin
  936.       needbox:=true; knt:=0;
  937.       for cnt:=1 to numuds do begin
  938.         b:=false;
  939.         seekudfile (cnt);
  940.         read (udfile,u);
  941.        if pos(upstring(t),upstring(u.filename))>0 then b:=true;
  942.         if pos(upstring(t),upstring(u.extdesc))>0 then b:=true;
  943.         if pos(upstring(t),upstring(u.programname))>0 then b:=true;
  944.     if b then begin
  945.             if needbox then begin writeln; topfileline; end;
  946.             listfile (cnt,false);
  947.             needbox:=false;
  948.             inc(knt); inc(totalcnt);
  949.           end;
  950.         if xpressed then exit;
  951.       end;
  952.       if not needbox then begin
  953.             bottomfileline;
  954.             writeln(^S+strr(knt)+^P+' files found.'^R);
  955.             writeln;
  956.              end;
  957.     end;
  958.  
  959.  
  960.   begin
  961.     writeln;
  962.     totalcnt:=0;
  963.     writestr ('Look in all areas? '^S'[y/n]'^R': *');
  964.     searchall:=yes;
  965.     writeln;
  966.     begin
  967.      writestr (^R'Enter '^P'TEXT'^R' to search for:');
  968.      writeln;
  969.      if length(input)=0 then exit;
  970.      stext:=input;
  971.      if not searchall then begin
  972.        writeln(^P'Looking for "'^S+stext+^P'" in current area.');
  973.        searchareatext(stext);
  974.        totalmatch;
  975.        exit;
  976.        end;
  977.      for cntt:=1 to numareas do begin
  978.        seekafile (cntt);
  979.        read (afile,a);
  980.        if urec.udlevel>=a.level then begin
  981.      setarea (cntt);
  982.      writeln;
  983.      writeln(^R'Searching for "'^S+stext+^R'" in ['^P,cntt,^R'] '+^S+area.name+^R'.');
  984.      searchareatext (stext);
  985.      if xpressed then exit;
  986.      end;
  987.      end;
  988.      totalmatch;
  989.     end;
  990.   end;
  991.  
  992.   procedure addresidentfile (fname:lstr);
  993.   var ud:udrec;
  994.       pointv:longint;
  995.       ccr:lstr;
  996.   begin
  997.     getpathname (fname,ud.path,ud.filename);
  998.     if match(fname,'USERS') then begin
  999.      writelog (16,10,unam);
  1000.      writeln (^G'SECURITY VIOLATION!  Paging Sysop.'^M);
  1001.      exit;
  1002.     end;
  1003.     getfsize(ud);
  1004.    {pointv:=pointvalue;
  1005.     pointv:=pointv*1000;}
  1006.     ud.points:=(ud.filesize div pointvalue div 1024);
  1007.     if ud.filesize=-1 then begin
  1008.      if not offliney then begin
  1009.       writeln ('File can''t be opened!');
  1010.       exit
  1011.      end;
  1012.     end;
  1013.     writestr (^P'File Size: '^S+strlong(ud.filesize)+^P' Point Value ['^S+strr(ud.points)+^P']:');
  1014.     if length(input)=0 then input:=strr(ud.points);
  1015.     ud.points:=valu(input);
  1016.     if ud.points<0 then ud.points:=0;
  1017.     writestr ('Sent by [CR/'+unam+']: &');
  1018.     if length(input)=0 then input:=unam;
  1019.     ud.sentby:=input;
  1020.     ud.when:=now;
  1021.     ud.whenrated:=now;
  1022.     ud.downloaded:=0;
  1023.     buflen:=27;
  1024.     writestr ('Program Description: &');
  1025.     ud.programname:=input;
  1026.     buflen:=2;
  1027.     writestr ('Disk Number: &');
  1028.     ud.disknum:=valu(input);
  1029.     if ud.disknum<1 then ud.disknum:=1;
  1030.     buflen:=2;
  1031.     writestr ('Total Disks: &');
  1032.     ud.totaldisk:=valu(input);
  1033.     if ud.totaldisk<1 then ud.totaldisk:=1;
  1034.    {writestr ('Description: &');
  1035.     ud.descrip:=input;}
  1036.     ud.extdesc:=getextdesc;
  1037.     if filepw then begin
  1038.      buflen:=30;
  1039.      writestr ('File Password [CR/None]: &');
  1040.      if length(input)=0 then ud.dlpw:='' else
  1041.      ud.dlpw:=input;
  1042.     end else
  1043.     ud.dlpw:='';
  1044.     buflen:=30;
  1045.     writestr ('Private for: &');
  1046.     if length(input)=0 then ud.private:='' else ud.private:=input;
  1047.     writestr ('Special Request only? [Ask]: *');
  1048.     ud.specialfile:=yes;
  1049.     ud.newfile:=false;
  1050.     addfile (ud);
  1051.     if zipcomment then begin
  1052.     writestr ('Add Zip Comment? [y/n]: *');
  1053.     if yes then begin
  1054.     addcomment (area.xmodemdir,ud.filename);
  1055.      end;
  1056.     end;
  1057.     ups:=ups+1;
  1058.     urec.uploads:=urec.uploads+1;
  1059.     if ud.filesize>-1 then
  1060.     urec.upk:=urec.upk+ud.filesize;
  1061.     writeurec;
  1062.     writelog (16,8,fname)
  1063.   end;
  1064.  
  1065.   procedure sysopadd;
  1066.   var fn,fnm,fp:lstr;
  1067.   begin
  1068.     if ulvl<sysoplevel then begin
  1069.       writeln
  1070.         ('Sorry, you may not add resident files without true sysop access!');
  1071.       exit
  1072.     end;
  1073.     writehdr ('Add Resident File');
  1074.     writestr ('Filename:');
  1075.     fnm:=upstring(input);
  1076.     writestr ('Path of File [CR/'+area.xmodemdir+']:');
  1077.     fp:=upstring(input);
  1078.     if length(fp)=0 then fp:=area.xmodemdir;
  1079.     if fp[length(fp)]<>'\' then fp:=fp+'\';
  1080.     fn:=fp+fnm;
  1081.     if exist(fn)
  1082.       then
  1083.         begin
  1084.           writestr ('Confirm: '+fn+' [y/n]:');
  1085.           if yes then addresidentfile (fn)
  1086.         end
  1087.       else begin
  1088.        writeln ('File not found!');
  1089.        if length(fn)=0 then exit;
  1090.        writestr ('Add it as? [Offline] [y/n]: *');
  1091.        if yes then begin
  1092.         offliney:=true;
  1093.         addresidentfile (fn);
  1094.         offliney:=false;
  1095.        end else exit;
  1096.      end;
  1097.   end;
  1098.  
  1099.  {function findfile (str:string):boolean;
  1100.   var i:integer;
  1101.       i2:integer;
  1102.       b:boolean;
  1103.   begin
  1104.   i2:=curarea;
  1105.   i:=1;
  1106.   while (numuds>=i) and (b=false) do begin
  1107.   seekudfile (i); if exist (datadir+'AREA'+strr(i)+'.'+strr(conn)) then begin
  1108.   read (udfile,ud); if (match(ud.filename,str)) then begin
  1109.   b:=true; end else b:=false; i:=i+1; end; end;
  1110.   i:=1; seekudfile (i2); read (udfile,ud);
  1111.   if b=true then writeln (^S+str+^P': '^R'Already exists!');
  1112.   end;}
  1113.  
  1114.   Procedure addmultiplefiles;
  1115.     Var spath,pathpart:lstr;
  1116.       dummy:sstr;
  1117.       f:File;
  1118.       ffinfo:searchrec;
  1119.     Begin
  1120.       If ulvl<sysoplevel Then Begin
  1121.       writeln (
  1122.         'Sorry, you may not add resident files without true sysop access!');
  1123.         exit
  1124.       End;
  1125.       writehdr('Add Multiple Files By Wildcard');
  1126.       writestr('Search path/wildcard:');
  1127.       If Length(Input)=0 Then exit;
  1128.       spath:=Input;
  1129.       If spath[Length(spath)]='\' Then dec(spath[0]);
  1130.       Assign(f,spath+'\con');
  1131.       Reset(f);
  1132.       If IOResult=0 Then Begin
  1133.         Close(f);
  1134.         spath:=spath+'\*.*'
  1135.       End;
  1136.       getpathname(spath,pathpart,dummy);
  1137.       findfirst(spath,$17,ffinfo);
  1138.       If doserror<>0
  1139.       Then WriteLn('No files found!')
  1140.       Else
  1141.         While doserror=0 Do Begin
  1142.           WriteLn;
  1143.           displayfile(ffinfo);
  1144.           writestr('Add this file? [Y/N/X]: *');
  1145.           If yes
  1146.           Then addresidentfile(getfname(pathpart,ffinfo.name))
  1147.           Else If (Length(Input)>0) And (UpCase(Input[1])='X')
  1148.             Then exit;
  1149.           findnext(ffinfo)
  1150.         End
  1151.     End;
  1152.  
  1153.   procedure changef;
  1154.   var n,q:integer;
  1155.       ud:udrec;
  1156.  
  1157.     procedure showudrec (var ud:udrec);
  1158.     var a,b,c:string;
  1159.     begin
  1160.       with ud do
  1161.         writeln(^M^J'     Filename: '^S,ud.filename,
  1162.                 ^M^J'         Path: '^S,ud.path,
  1163.                 ^M^J'         Size: '^S,ud.filesize,
  1164.                 ^M^J'    File Cost: '^S,ud.points,
  1165.                {^M^J'  Description: '^S,ud.descrip, }
  1166.                 ^M^J' Program Desc: '^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
  1167.     strr(ud.totaldisk),
  1168.                 ^M^J' # Downloaded: '^S,ud.downloaded,
  1169.                 ^M^J'      Unrated: '^S,yesno(ud.newfile),
  1170.                 ^M^J'  Special Ask: '^S,yesno(ud.specialfile),
  1171.                 ^M^J'      Sent by: '^S,sentby,
  1172.                 ^M^J'      Sent on: '^S,datestr(when),
  1173.                 ^M^J'      Sent at: '^S,timestr(when));
  1174.         if filepw then begin
  1175.          write ('File Password: '^S);
  1176.          if length(ud.dlpw)<1 then writeln ('NONE') else
  1177.          writeln (ud.dlpw);
  1178.         end;
  1179.          write (' Private File: '^S);
  1180.          if length(ud.private)<1 then writeln ('No') else
  1181.          writeln ('Yes  '+ud.private);
  1182.         writeln ('Extended Desc: '^S);
  1183.     a:=copy (ud.extdesc,1,80);
  1184.     ansicolor (urec.statcolor);
  1185.     writeln (a);
  1186.     if length(ud.extdesc)>80 then begin
  1187.      b:=copy (ud.extdesc,81,80);
  1188.      ansicolor (urec.statcolor);
  1189.      writeln (b);
  1190.     end;
  1191.     if length(ud.extdesc)>160 then begin
  1192.      c:=copy (ud.extdesc,161,80);
  1193.      ansicolor (urec.statcolor);
  1194.      writeln (c);
  1195.     end;
  1196.     end;
  1197.  
  1198.   begin
  1199.     n:=getfilenum ('Change');
  1200.     if n=0 then exit;
  1201.     seekudfile (n);
  1202.     read (udfile,ud);
  1203.     writelog (16,4,ud.filename);
  1204.     showudrec (ud);
  1205.     repeat
  1206.       q:=menu ('File Change','FCHANGE','QUSNFPVAEDTRC?');
  1207.       case q of
  1208.         2:getstring ('Uploader',ud.sentby);
  1209.        {3:begin
  1210.             nochain:=true;
  1211.             getstring ('Description',ud.descrip)
  1212.           end;}
  1213.         3:getboo ('Special Request only',ud.specialfile);
  1214.         4:getboo ('New File (unrated)',ud.newfile);
  1215.         5:getstring ('Filename',ud.filename);
  1216.         6:getstring ('Path',ud.path);
  1217.         7:getint ('File Cost',ud.points);
  1218.         8:if (not filepw) then writeln ('File Passwords were not configured!')
  1219.           else getstringgg ('File Password',ud.dlpw);
  1220.         9:ud.extdesc:=getextdesc;
  1221.         10:getstring ('Program Description',ud.programname);
  1222.         11:begin buflen:=2; getint ('Disk Number',ud.disknum);
  1223.            buflen:=2; getint ('Total Disks',ud.totaldisk);
  1224.            end;
  1225.         12:getstringgg ('Private File',ud.private);
  1226.         13:addcomment (ud.path,ud.filename);
  1227.         14:begin
  1228.            fchangemenu;
  1229.            end;
  1230.  
  1231.       end
  1232.     until (q=1);
  1233.     getfsize(ud);
  1234.     if ud.filesize=-1 then writestr ('Warning:  Can''t open file!');
  1235.     seekudfile (n);
  1236.     write (udfile,ud)
  1237.   end;
  1238.  
  1239.   procedure deletef;
  1240.   var n,cnt,anarky:integer;
  1241.       fn:lstr;
  1242.       ud:udrec;
  1243.       f:file;
  1244.       floyd:userrec;
  1245.   begin
  1246.     n:=getfilenum ('Delete');
  1247.     if n=0 then exit;
  1248.     seekudfile (n);
  1249.     read (udfile,ud);
  1250.     fn:=getfname(ud.path,ud.filename);
  1251.     writelog (16,7,fn);
  1252.     writeln;
  1253.     writehdr ('Delete File');
  1254.     writeln (^R'Filename:    '^S,fn);
  1255.     writeln (^R'Size:        '^S,ud.filesize);
  1256.     writeln (^R'Program Desc:'^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
  1257.     strr(ud.totaldisk));
  1258.     writeln (^R'Downloaded:  '^S,ud.downloaded);
  1259.     writeln (^R'Uploaded by: '^S,ud.sentby);
  1260.     writeln (^R);
  1261.     writestr ('Delete this? [y/n]: *');
  1262.     if not yes then exit;
  1263.     removefile (n);
  1264.     if ups<1 then ups:=1;
  1265.     ups:=ups-1;
  1266.     if urec.lastups<1 then urec.lastups:=1;
  1267.     urec.lastups:=urec.lastups-1;
  1268.     writeurec;
  1269.     writestr ('Remove upload credits from uploader [y/n]? *');
  1270.     if yes then begin
  1271.      anarky:=lookupuser (ud.sentby);
  1272.      if anarky<>0 then begin
  1273.       writeurec;
  1274.       seek (ufile,anarky);
  1275.       read (ufile,floyd);
  1276.       floyd.uploads:=floyd.uploads-1;
  1277.       floyd.upk:=floyd.upk-ud.filesize;
  1278.       seek (ufile,anarky);
  1279.       write (ufile,floyd);
  1280.       readurec
  1281.      end;
  1282.     end;
  1283.     writestr ('Erase Disk File '+fn+'? [y/n]: *');
  1284.     if not yes then exit;
  1285.     assign (f,fn);
  1286.     erase (f)
  1287.   end;
  1288.  
  1289.   procedure killarea;
  1290.   var a:arearec;
  1291.       cnt,n:integer;
  1292.       oldname,newname:sstr;
  1293.   begin
  1294.     writestr (^R'Delete Area #'^S+strr(curarea)+^R' ['^S+area.name+^R']: *');
  1295.     if not yes then exit;
  1296.     writelog (16,2,'');
  1297.     ups:=ups-numuds;
  1298.     urec.lastups:=urec.lastups-numuds;
  1299.     if ups<1 then ups:=1;
  1300.     if urec.lastups<1 then urec.lastups:=1;
  1301.     writeurec;
  1302.     close (udfile);
  1303.     oldname:='Area'+strr(curarea)+'.'+strr(conn);
  1304.     erase (udfile);
  1305.     for cnt:=curarea to numareas-1 do begin
  1306.       newname:=oldname;
  1307.       oldname:='Area'+strr(cnt+1)+'.'+strr(conn);
  1308.       assign (udfile,datadir+oldname);
  1309.       rename (udfile,datadir+newname);
  1310.       n:=ioresult;
  1311.       seekafile (cnt+1);
  1312.       read (afile,a);
  1313.       seekafile (cnt);
  1314.       write (afile,a)
  1315.     end;
  1316.     seekafile (numareas);
  1317.     truncate (afile);
  1318.     setarea (1);
  1319.   end;
  1320.  
  1321.   procedure modarea;
  1322.   var a:arearec;
  1323.       q:char;
  1324.   begin
  1325.     a:=area;
  1326.     repeat
  1327.     clearscr;
  1328.     writehdr ('Modify Area');
  1329.     writeln(^P'['^S'A'^P'] '^R'Area Name   : '^S+a.name);
  1330.     writeln(^P'['^S'B'^P'] '^R'Access Level: '^S+strr(a.level));
  1331.     writeln(^P'['^S'C'^P'] '^R'Area Sponsor: '^S+a.sponsor);
  1332.     writeln(^P'['^S'D'^P'] '^R'Entry PW    : '^S+a.areapw);
  1333.     write  (^P'['^S'E'^P'] '^R'Allow U/Ls  : '^S);
  1334.     if a.upload then writeln('Yes') else
  1335.     writeln(^S'No');
  1336.     write  (^P'['^S'F'^P'] '^R'Allow D/Ls  : '^S);
  1337.     if a.download then writeln('Yes') else
  1338.     writeln(^S'No');
  1339.     if issysop then
  1340.     writeln(^P'['^S'G'^P'] '^R'Xfer Path   : '^S+a.xmodemdir+^M);
  1341.     writestr (^P'['^R'Area Modify Command'^P']'^S': *');
  1342.     if hungupon then exit;
  1343.     q:=upcase(input[1]);
  1344.     case q of
  1345.      'A':begin getstringgg ('Area Name',a.name);
  1346.      writelog (16,3,a.name);
  1347.       seekafile (curarea);
  1348.       write (afile,a);
  1349.       area:=a
  1350.      end;
  1351.      'B':begin getint ('Access Level',a.level);
  1352.      writelog (16,11,strr(a.level));
  1353.       seekafile (curarea);
  1354.       write (afile,a);
  1355.       area:=a
  1356.      end;
  1357.      'C':begin getstringgg ('Sponsor',a.sponsor);
  1358.      writelog (16,12,a.sponsor);
  1359.       seekafile (curarea);
  1360.       write (afile,a);
  1361.       area:=a
  1362.      end;
  1363.      'D':begin getstringgg ('Entry Password',a.areapw);
  1364.      writelog (16,18,a.areapw);
  1365.       seekafile (curarea);
  1366.       write (afile,a);
  1367.       area:=a
  1368.      end;
  1369.      'E':begin getboo ('Able to Upload into area',a.upload);
  1370.       seekafile (curarea);
  1371.       write (afile,a);
  1372.       area:=a
  1373.      end;
  1374.      'F':begin getboo ('Able to Download from area',a.download);
  1375.       seekafile (curarea);
  1376.       write (afile,a);
  1377.       area:=a
  1378.      end;
  1379.      'G':if issysop then begin
  1380.       a.xmodemdir:=getapath;
  1381.       seekafile (curarea);
  1382.       write (afile,a);
  1383.       area:=a;
  1384.       writelog (16,13,a.xmodemdir)
  1385.      end;
  1386.     end;
  1387.   until q='Q';
  1388.     seekafile (curarea);
  1389.     write (afile,a);
  1390.     area:=a
  1391.   end;
  1392.  
  1393.   procedure sortarea;
  1394.   var temp,mark,cnt:integer;
  1395.       u1,u2:udrec;
  1396.   begin
  1397.     writehdr('Sort File Area'); writeln;
  1398.     writestr('Are you sure? '+^S+'[y/n]'+^P+':');
  1399.     if not yes then exit;
  1400.     writelog (16,6,'');
  1401.     mark:=numuds-1;
  1402.     repeat
  1403.       if mark<>0 then begin
  1404.         temp:=mark;
  1405.         mark:=0;
  1406.         for cnt:=1 to temp do begin
  1407.           seekudfile (cnt);
  1408.           read (udfile,u1);
  1409.           read (udfile,u2);
  1410.           if upstring(u1.filename)>upstring(u2.filename) then begin
  1411.             mark:=cnt;
  1412.             seekudfile (cnt);
  1413.             write (udfile,u2);
  1414.             write (udfile,u1)
  1415.           end;
  1416.         end
  1417.       end
  1418.     until mark=0
  1419.   end;
  1420.  
  1421.   procedure movefile;
  1422.   var an,fn,oldn:integer;
  1423.       ud:udrec;
  1424.       pe:boolean; sz:real;
  1425.       lttp,laym,honkyshide,ocky:anystr;
  1426.       damn:file; drive:char; r:registers;
  1427.  
  1428.       function unsigned (i:integer):real;
  1429.       begin
  1430.         if i>=0 then unsigned:=i else unsigned:=65536.0+i
  1431.       end;
  1432.  
  1433.  
  1434.  
  1435.   begin
  1436.     oldn:=curarea;
  1437.     fn:=getfilenum ('Move');
  1438.     if fn=0 then exit;
  1439.     input:='';
  1440.     an:=getareanum;
  1441.     if an=0 then exit;
  1442.     writestr ('Physically move file to correct area? [y/n]: *');
  1443.     if yes then pe:=true else pe:=false;
  1444.     seekudfile (fn);
  1445.     read (udfile,ud);
  1446.     writelog (16,5,ud.filename);
  1447.     laym:=getfname(ud.path,ud.filename);
  1448.     ocky:=ud.path;
  1449.     write('Moving.');
  1450.     setarea (an);
  1451.     if (not match(ud.path,area.xmodemdir)) and (pe) then begin
  1452.          ud.path:=area.xmodemdir;
  1453.          lttp:=getfname(ud.path,ud.filename);
  1454.          drive:=upcase(lttp[1]);
  1455.         r.ah:=$36; r.dl:=ord(drive)-64;
  1456.         intr($21,r);
  1457.         if r.ax=$ffff then begin
  1458.                 writeln;
  1459.                 writeln('Dest. Drive does not exist!');
  1460.                 exit;
  1461.                 end;
  1462.  
  1463.         sz:=unsigned(r.bx)*unsigned(r.ax)*unsigned(r.cx); writeln;
  1464.     writeln;
  1465. writeln('There are ',^S,streal(sz),^R,' bytes free on the '^S,drive,^R,' drive.');
  1466.         if sz<=ud.filesize then begin
  1467.         writeln;
  1468.     writeln('That is not enough space for this file.  You must clear up another');
  1469.     writeln(^S,streal(ud.filesize-sz),^R,' bytes to continue.');
  1470.         exit;
  1471.         end;
  1472.             write('Copying.');
  1473.          exec(getenv('COMSPEC'),'/C copy '+laym+' '+lttp);
  1474.          honkyshide:=laym;
  1475.  
  1476.          assign(damn,honkyshide);
  1477.          if exist(honkyshide) then erase (damn) else begin
  1478.           ud.path:=ocky;
  1479.           writeln('ERROR: Unable to move file!');
  1480.           end;
  1481.     end;
  1482.     addfile (ud);
  1483.     setarea (oldn);
  1484.     removefile (fn);
  1485.     writeln(' - Done.');
  1486.   end;
  1487.  
  1488.   procedure renamefile;
  1489.   var fn:integer;
  1490.       ud:udrec;
  1491.       f:file;
  1492.   begin
  1493.     fn:=getfilenum ('Rename');
  1494.     if fn=0 then exit;
  1495.     seekudfile (fn);
  1496.     read (udfile,ud);
  1497.     writestr ('Enter new Filename: *');
  1498.     if match(input,ud.filename)
  1499.       then
  1500.         ud.filename:=input
  1501.       else if length(input)>0
  1502.         then if validfname(input)
  1503.           then if exist(getfname(ud.path,input))
  1504.             then
  1505.               writeln ('Name already in use!')
  1506.             else
  1507.               begin
  1508.                 assign (f,getfname(ud.path,ud.filename));
  1509.                 rename (f,getfname(ud.path,input));
  1510.                 if ioresult=0 then begin
  1511.                   ud.filename:=input;
  1512.                   writeln (^B^M'File renamed.')
  1513.                 end else writeln (^B^M'Unable to rename file!')
  1514.               end
  1515.           else writeln ('Invalid filename!');
  1516.     seekudfile (fn);
  1517.     write (udfile,ud)
  1518.   end;
  1519.  
  1520.   procedure listxmodem;
  1521.   var cnt:integer;
  1522.       u:userrec;
  1523.   begin
  1524.     seek (ufile,1);
  1525.     writeln ('Name                          Level Points'^M);
  1526.     for cnt:=1 to numusers do begin
  1527.       read (ufile,u);
  1528.       if u.handle<>'' then
  1529.         if u.udlevel>0 then begin
  1530.           tab (u.handle,30);
  1531.           tab (strr(u.udlevel),6);
  1532.           writeln (u.udpoints);
  1533.           if break then exit
  1534.         end
  1535.     end
  1536.   end;
  1537.  
  1538.   Procedure reorderareas;
  1539.     Var numa,cura,newa:Integer;
  1540.       a1,a2:arearec;
  1541.       f1,f2:File;
  1542.       fn1,fn2:sstr;
  1543.     Label exit;
  1544.     Begin
  1545.       writelog(16,9,'');
  1546.       writehdr('Re-order Areas');
  1547.       numa:=FileSize(afile);
  1548.       WriteLn('Number of areas: ',numa);
  1549.       For cura:=0 To numa-2 Do Begin
  1550.         Repeat
  1551.           writestr ('[New Area #'+strr(cura+1)+'] [?/List, CR/Quit]:');
  1552.           If Length(Input)=0 Then GoTo exit;
  1553.           If Input='?'
  1554.           Then
  1555.             Begin
  1556.               listareas;
  1557.               newa:=-1
  1558.             End
  1559.           Else
  1560.             Begin
  1561.               newa:=valu(Input)-1;
  1562.               If (newa<0) Or (newa>numa) Then Begin
  1563.                 WriteLn('Not found!  Please re-enter.');
  1564.                 newa:=-1
  1565.               End
  1566.             End
  1567.         Until (newa>=0);
  1568.         Seek(afile,cura);
  1569.         Read(afile,a1);
  1570.         Seek(afile,newa);
  1571.         Read(afile,a2);
  1572.         Seek(afile,cura);
  1573.         Write(afile,a2);
  1574.         Seek(afile,newa);
  1575.         Write(afile,a1);
  1576.         fn1:=datadir+'Area';
  1577.         fn2:=fn1+strr(newa+1)+'.'+strr(conn);
  1578.         fn1:=fn1+strr(cura+1)+'.'+strr(conn);
  1579.         Assign(f1,fn1);
  1580.         Assign(f2,fn2);
  1581.         Rename(f1,'TempArea');
  1582.         Rename(f2,fn1);
  1583.         Rename(f1,fn2);
  1584.         close (f1);
  1585.         close (f2);
  1586.       End;
  1587.      exit:
  1588.       setarea(1)
  1589.     End;
  1590.  
  1591.   procedure newfiles;
  1592.   var a,fn,un:integer;
  1593.       ud:udrec;
  1594.       u:userrec;
  1595.       flag,aborted:boolean;
  1596.  
  1597.    procedure writeudrec;
  1598.     begin
  1599.       seekudfile (fn);
  1600.       write (udfile,ud)
  1601.     end;
  1602.  
  1603.     procedure ratefile (p:integer);
  1604.     var pp:integer;
  1605.     begin
  1606.       ud.points:=p;
  1607.       ud.newfile:=false;
  1608.       ud.whenrated:=now;
  1609.       writeudrec;
  1610.       p:=p*uploadfactor;
  1611.       if p>-2 then begin
  1612.         un:=lookupuser (ud.sentby);
  1613.         if un=0
  1614.           then writeln (ud.sentby,' has vanished!')
  1615.           else begin
  1616.             pp:=p;
  1617.             writestr (^P'Actually grant '^S+ud.sentby+^P' how many points ['^S+strr(p)+^P']:');
  1618.             if (length(input)=0) then pp:=p else pp:=valu(input);
  1619.             writeln ('Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
  1620.             if un=unum then writeurec;
  1621.             seek (ufile,un);
  1622.             read (ufile,u);
  1623.             u.udpoints:=u.udpoints+pp;
  1624.             seek (ufile,un);
  1625.             write (ufile,u);
  1626.             if un=unum then readurec
  1627.           end
  1628.       end
  1629.     end;
  1630.  
  1631.     procedure doarea;
  1632.     var i,advance:integer;
  1633.         done:boolean;
  1634.     begin
  1635.       fn:=1;
  1636.       advance:=0;
  1637.       while fn+advance<=numuds do begin
  1638.         fn:=fn+advance;
  1639.         advance:=1;
  1640.         seekudfile (fn);
  1641.         read (udfile,ud);
  1642.         if ud.newfile then begin
  1643.           flag:=false;
  1644.           done:=false;
  1645.           repeat
  1646.             writeln (^B^M'Filename:    ',ud.filename,
  1647.                        ^M'Path:        ',ud.path,
  1648.                        ^M'Sent by:     ',ud.sentby,
  1649.                        ^M'File size:   ',ud.filesize,
  1650.                        ^M'Program Desc:',ud.programname+' '+strr(ud.disknum)+'/'^S+
  1651.     strr(ud.totaldisk));
  1652.             i:=menu ('File Newscan','NEWSCAN','Q#_CEPDTRM0?');
  1653.             input:=' '+strr(fn);
  1654.             if i<0
  1655.               then
  1656.                 begin
  1657.                   ratefile (-i);
  1658.                   done:=true
  1659.                 end
  1660.               else
  1661.                 case i of
  1662.                   1:begin
  1663.                       aborted:=true;
  1664.                       exit
  1665.                     end;
  1666.                   3:done:=true;
  1667.                   4:begin
  1668.                       writestr ('Enter new Program Description:');
  1669.                       if length(input)>0 then ud.programname:=input;
  1670.                       writeudrec
  1671.                     end;
  1672.                   5:begin
  1673.                     writestr ('Enter new Disk Number:');
  1674.                     if length(input)>0 then ud.disknum:=valu(input);
  1675.                     writeudrec
  1676.                     end;
  1677.                   6:begin
  1678.                     writestr ('Enter new Total Disks Number:');
  1679.                     if length(input)>0 then ud.totaldisk:=valu(input);
  1680.                     writeudrec
  1681.                     end;
  1682.                   7:begin
  1683.                       renamefile;
  1684.                       advance:=0
  1685.                     end;
  1686.                   8:begin
  1687.                       deletef;
  1688.                       advance:=0
  1689.                     end;
  1690.                   9:listarchive (fn);
  1691.                  10:begin
  1692.                       movefile;
  1693.                       advance:=0
  1694.                     end;
  1695.                  11:begin
  1696.                       ratefile (0);
  1697.                       done:=true
  1698.                     end;
  1699.                  12:begin
  1700.                     newscanmenu;
  1701.                     end;
  1702.                 end
  1703.           until done or (advance=0)
  1704.         end
  1705.       end;
  1706.     end;
  1707.  
  1708.   begin
  1709.     flag:=true;
  1710.     writelog (16,1,'');
  1711.     if issysop then begin
  1712.       writestr ('Scan all areas? [y/n]: *');
  1713.       if yes then begin
  1714.         for a:=1 to numareas do begin
  1715.           setarea (a);
  1716.           aborted:=false;
  1717.           doarea;
  1718.           if aborted then exit
  1719.         end;
  1720.       end else begin doarea; end
  1721.     end else begin doarea; end;
  1722.     if flag then writeln (^B'No new files.')
  1723.   end;
  1724.  
  1725.   procedure generatelist;
  1726.   var total,a,b,c,x,y,z:integer;
  1727.       list:text;
  1728.       yoo,ud:udrec;
  1729.       s:anystr;
  1730.       f:file;
  1731.       str1,str2:string;
  1732.   begin
  1733.    total:=0;
  1734.    writehdr ('Generate Master File List');
  1735.    writestr ('Make complete list of all files available? [y/n]: *');
  1736.    if not yes then exit;
  1737.    if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
  1738.    assign (list,faqdir+'MASTER.'+strr(conn));
  1739.    rewrite (list);
  1740.    writeln (list);
  1741.    writeln (list,'[Master File List created by FAQ v'+ver+' for '+longname+']');
  1742.    writeln (list);
  1743.    writeln (list,'Num. Filename     Description');
  1744.    writeln (list,'───────────────────────────────────────────────────────────────────────────────');
  1745.    for x:=1 to numareas do begin
  1746.     setarea (x);
  1747.     writeln (list);
  1748.     writeln (list,'Area: ',area.name,' [',curarea,']');
  1749.     writeln (list);
  1750.     for y:=1 to numuds do
  1751.     begin
  1752.      seekudfile(y);
  1753.      read (udfile,yoo);
  1754.      total:=total+1;
  1755.      write (list,strr(total)+'.');
  1756.      for a:=1 to 5-(length(strr(total)+'.')) do write (list,' ');
  1757.      write (list,yoo.filename);
  1758.      for b:=1 to 13-(length(yoo.filename)) do write (list,' ');
  1759.     if exist (getfname(yoo.path,yoo.filename)) then begin
  1760.      write (list,strlong(yoo.filesize));
  1761.      for c:=1 to 10-(length(strlong(yoo.filesize))) do write (list,' ');
  1762.     end else
  1763.     write (list,'[Offline] ');
  1764.     writeln (list,yoo.programname+' '+strr(yoo.disknum)+'/'+strr(yoo.totaldisk));
  1765.     end;
  1766.    end;
  1767.    writeln (list);
  1768.    writeln (list,'- '+strr(total)+' Files Processed');
  1769.    writeln (list,'- List generated by FAQ v'+ver);
  1770.    textclose (list);
  1771.    setarea (1);
  1772.    writeln;
  1773.    writeln ('Please wait while file is being Zipped up.');
  1774.    addtozip (area.xmodemdir+'ALLFILES.ZIP',faqdir+'MASTER.'+strr(conn));
  1775.    writeln (usr);
  1776.    if not exist (area.xmodemdir+'ALLFILES.ZIP') then begin
  1777.     writeln ('Cannot locate temporary Zipfile '+area.xmodemdir+'ALLFILES.ZIP!');
  1778.     exit;
  1779.    end;
  1780.    writeln;
  1781.    ud.filename:='ALLFILES.ZIP';
  1782.    ud.path:=area.xmodemdir;
  1783.    ud.dlpw:='';
  1784.    ud.sentby:=unam;
  1785.    ud.when:=now;
  1786.    ud.whenrated:=now;
  1787.    ud.points:=0;
  1788.    ud.downloaded:=0;
  1789.    ud.newfile:=false;
  1790.    ud.specialfile:=false;
  1791.    ud.extdesc:='Master file list for '+longname;
  1792.    getfsize (ud);
  1793.    addfile (ud);
  1794.    writeln (^R'Downloading '^S+ud.filename+^R'.');
  1795.    download (numuds,false);
  1796.    removefile (numuds);
  1797.    assign (f,getfname(ud.path,ud.filename));
  1798.    erase (f);
  1799.    writelog (16,18,unam);
  1800.   end;
  1801.  
  1802.   procedure extractfile;
  1803.   var n:integer;
  1804.       ud,scratch:udrec;
  1805.       ok,done:boolean;
  1806.       effn,master,dir,sname,tempfn:anystr;
  1807.   begin
  1808.    n:=getfilenum ('Extract from');
  1809.    if n=0 then exit;
  1810.    seekudfile (n);
  1811.    read (udfile,ud);
  1812.    ok:=checkok (ud);
  1813.    if not ok then exit;
  1814.    writeln;
  1815.    writeln (^R'Archive Filename: '^S,ud.filename,^R);
  1816.    done:=false;
  1817.    repeat
  1818.     writeln;
  1819.     writeln (^R'Enter Filename to extract from Archive, or hit [V] to View.');
  1820.     writestr (': *');
  1821.     if length(input)=0 then exit;
  1822.     if upstring(input)='V' then listarchive (n) else
  1823.     done:=true;
  1824.    until done or hungupon;
  1825.    effn:=upstring(input);
  1826.   {setarea (1);}
  1827.    dir:=area.xmodemdir;
  1828.    if dir[length(dir)]<>'\' then dir:=dir+'\';
  1829.    if exist(effn) then begin
  1830.      writeln ('File Already Exists!');
  1831.      exit;
  1832.    end;
  1833.    master:=getfname (ud.path,ud.filename);
  1834.    extract (effn,master,dir);
  1835.    tempfn:=effn;
  1836.    effn:=getfname(dir,effn);
  1837.    if not exist (effn) then begin
  1838.     writeln (^G);
  1839.     writeln ('Error! Cannot find extracted file '+effn);
  1840.     writeln ('Please notify Sysop!');
  1841.     exit;
  1842.    end;
  1843.    writeln (usr);
  1844.    sname:=copy (tempfn,1,(pos ('.',tempfn)));
  1845.    writeln ('Please wait while file is being Zipped up.');
  1846.    addtozip (dir+sname+'ZIP',effn);
  1847.    writeln (usr);
  1848.    if not exist (dir+sname+'ZIP') then begin
  1849.     writeln ('Cannot locate temporary Zipfile '+dir+sname+'ZIP!');
  1850.     exit;
  1851.    end;
  1852.    scratch.filename:=sname+'ZIP';
  1853.    scratch.path:=dir;
  1854.    scratch.dlpw:='';
  1855.    scratch.sentby:=unam;
  1856.    scratch.when:=now;
  1857.    scratch.whenrated:=now;
  1858.    scratch.points:=1;
  1859.    scratch.downloaded:=0;
  1860.    scratch.newfile:=false;
  1861.    scratch.specialfile:=false;
  1862.    scratch.extdesc:='Temporary Zipfile for downloading by '+unam+' ONLY.';
  1863.    getfsize (scratch);
  1864.    addfile (scratch);
  1865.    writeln (^R'Downloading '^S+scratch.filename+^R'.');
  1866.    download (numuds,false);
  1867.    removefile (numuds);
  1868.    writelog (16,19,ud.filename);
  1869.   end;
  1870.  
  1871.  
  1872.   procedure renameallfiles;
  1873.   var e,c,w:sstr;
  1874.       i,yiyi:integer;
  1875.       u:udrec;
  1876.       f:lstr;
  1877.       bpb:boolean;
  1878.   begin
  1879.    writehdr ('Convert All File Extensions');
  1880.    writeln (^R'This is for if you are converting all your files to ZIP');
  1881.    writeln (^R'format, or are converting them all to PAK format, etc.');
  1882.    writeln (^R'Instead of you having to change the file extensions by hand');
  1883.    writeln (^R'this will do it for you.');
  1884.    writeln (^S'But you must do the actual file converting YOURSELF.');
  1885.    writeln (^R^B);
  1886.    writeln (^S'Enter Global File Extension (ie ZIP), or [CR] to exit: ');
  1887.    buflen:=3;
  1888.    writestr (': *');
  1889.    if length(input)=0 then exit;
  1890.    e:=input;
  1891.    writeln;
  1892.    bpb:=match (longname,'The Flaming Pit');
  1893.    if bpb then begin
  1894.     writeln ('Enter Global "Who Uploaded this File":');
  1895.     writestr (': &');
  1896.     w:=input;
  1897.    end;
  1898.    for i:=1 to filesize(udfile) do begin
  1899.     if aborted then exit;
  1900.     seekudfile (i);
  1901.     read (udfile,u);
  1902.     yiyi:=0;
  1903.     f:='';
  1904.     c:='';
  1905.     repeat
  1906.      yiyi:=yiyi+1;
  1907.      c:=copy (u.filename,yiyi,1);
  1908.      f:=f+c;
  1909.     until (c='.') or (yiyi=length(u.filename));
  1910.     writeln ('Pass Number:  ',i);
  1911.     u.filename:=f+e;
  1912.     writeln ('New Filename: ',u.filename);
  1913.     if (bpb) and (length(w)>0) then begin
  1914.      u.sentby:=w;
  1915.      writeln ('New Uploader: ',u.sentby);
  1916.     end;
  1917.     seekudfile (i);
  1918.     write (udfile,u);
  1919.    end
  1920.   end;
  1921.  
  1922.   procedure showinfo (n:integer);
  1923.   var ud:udrec;
  1924.   begin
  1925.    if n>numuds then exit;
  1926.    seekudfile (n);
  1927.    read (udfile,ud);
  1928.  
  1929.   end;
  1930.  
  1931.   procedure newscan;
  1932.   var cnt,aka,insane:integer;
  1933.       u:udrec;
  1934.       gnuwarez,done,non:boolean;
  1935.       c:char;
  1936.   begin
  1937.     vcr:=false;
  1938.     gnuwarez:=false;
  1939.     beenaborted:=false;
  1940.     aka:=0;
  1941.     cn:=0;
  1942.     non:=false;
  1943.     repeat
  1944.     cn:=0;
  1945.     non:=false;
  1946.     for cnt:=1 to filesize(udfile) do begin
  1947.       if aborted then exit;
  1948.       seekudfile (cnt);
  1949.       read (udfile,u);
  1950.       if (u.whenrated>laston) or (u.when>laston)
  1951.       then begin
  1952.       inc(cn);
  1953.       if (cn=18) and (non=false) then
  1954.       begin
  1955.        bottomfileline;
  1956.        cn:=0;
  1957.       writestr (^S'CR'^P'/'^R'Next  '^S'+'^P'/'^R'Add to batch  '^S'D'^R'ownload  '^S'N'^R'on-stop  '^S
  1958.       +'Q'^R'uit  '^S'V'^R'iew'^P': '^U'*');
  1959.       if capfir(input)='A' then addtobatch (0);
  1960.       if capfir(input)='D' then download (0,true);
  1961.       if capfir(input)='N' then non:=true;
  1962.       if capfir(input)='Q' then exit;
  1963.       if capfir(input)='V' then listarchive (0);
  1964.        writeln;
  1965.        topfileline;
  1966.       end;
  1967.  
  1968.          aka:=aka+1;
  1969.          if aka=1 then begin
  1970.           clearscr;
  1971.           writeln (^R'['^S,curarea,^R']  ['^S,area.name,^R']'^M);
  1972.           topfileline;
  1973.          end;
  1974.  
  1975.          listfile (cnt,false);
  1976.          gnuwarez:=true;
  1977.         end;
  1978.        end;
  1979.  
  1980.     if not gnuwarez then done:=true else done:=false;
  1981.     if gnuwarez then begin
  1982.      c:='N';
  1983.      bottomfileline;
  1984.      writeln;
  1985.      writestr (^P'Newscan Command ['^S'?/Help'^P'] ['^S'CR/Next Area'^P']'^S': '^U'*');
  1986.      if length(input)<1 then input:='N';
  1987.      c:=input[1];
  1988.      insane:=valu(input);
  1989.      c:=upcase(c);
  1990.      if (insane>0) and (insane<=numuds) then begin
  1991.       showinfo (insane);
  1992.       writeln;
  1993.       writestr ('Hit [Enter]:');
  1994.      end else
  1995.        c:=upcase(input[1]);
  1996.        if length(input)=0 then done:=true else
  1997.        case c of
  1998.         '?':begin
  1999.               writeln;
  2000.               writeln (^S'          -File Xfer Newscan Help-'^R^M);
  2001.               writeln ('[N]: Next File Area        [I]: More Info on a File ');
  2002.               writeln ('[A]: See Files Again       [V]: View a File (ZIP/ARC/PAK/LZH)');
  2003.               writeln ('[D]: Download a File       [+]: Add file to Batch');
  2004.               writeln ('[Q]: Quit Newscan');
  2005.               if sponsoron then begin
  2006.                writeln (^S'              -Sysop Commands- '^R);
  2007.                writeln ('[C]: Change a File         [!]: Validate all New Files');
  2008.                writeln ('[R]: Rename a File         [E]: Delete a File');
  2009.               end;
  2010.               writeln;
  2011.               aka:=0;
  2012.               writestr (^M'Hit [Enter] to continue.*');
  2013.               aka:=0;
  2014.             end;
  2015.         '+':begin
  2016.              writeln;
  2017.              addtobatch (0);
  2018.              writestr (^M'Hit [Enter] to continue.*');
  2019.              aka:=0;
  2020.             end;
  2021.         'D':begin
  2022.              writeln;
  2023.              download (0,true);
  2024.              writestr (^M'Hit [Enter] to continue.*');
  2025.              aka:=0;
  2026.             end;
  2027.         'A':begin
  2028.              done:=false;
  2029.              aka:=0;
  2030.             end;
  2031.         'V':begin
  2032.              writeln;
  2033.              listarchive (0);
  2034.              writestr (^M'Hit [Enter] to continue.*');
  2035.              aka:=0;
  2036.             end;
  2037.         'Q':begin
  2038.              vcr:=true;
  2039.              exit;
  2040.             end;
  2041.         'C':begin
  2042.              if not sponsoron then exit;
  2043.              changef;
  2044.              aka:=0;
  2045.             end;
  2046.         'R':begin
  2047.              if not sponsoron then exit;
  2048.              renamefile;
  2049.              aka:=0;
  2050.             end;
  2051.         'E':begin
  2052.              if not sponsoron then exit;
  2053.              deletef;
  2054.              aka:=0;
  2055.             end;
  2056.         '!':begin
  2057.              if not sponsoron then exit;
  2058.              newfiles;
  2059.              aka:=0;
  2060.             end;
  2061.         'I':begin
  2062.              writeln;
  2063.              fileinfo (0);
  2064.              aka:=0;
  2065.              writestr ('Hit [Enter] to continue.*');
  2066.             end;
  2067.         'N':done:=true;
  2068.        end;
  2069.       end;
  2070.     until done;
  2071.   end;
  2072.  
  2073.   procedure newscanall;
  2074.   var cnt:integer;
  2075.       a:arearec;
  2076.   begin
  2077.     writeln (^R'Newscanning All Areas - Press ['^S'X'^R'] to Abort.'^M);
  2078.     beenaborted:=false;
  2079.     if aborted then exit;
  2080.     for cnt:=1 to filesize(afile) do begin
  2081.       seekafile (cnt);
  2082.       read (afile,a);
  2083.       if urec.udlevel>=a.level then begin
  2084.         if aborted then exit;
  2085.         setarea (cnt);
  2086.         writeln (^R+area.name+^P' ['^S+strr(curarea)+^P']');
  2087.         if aborted or vcr then exit;
  2088.         newscan;
  2089.       end;
  2090.       if aborted then exit
  2091.     end;
  2092.    writeln (^R^M'Newscan complete!'^G);
  2093.   end;
  2094.  
  2095.  
  2096.   procedure yourudstats;
  2097.   begin
  2098.      yourudstatus;
  2099.      clearscr;
  2100.    end;
  2101.  
  2102.   procedure sysopcommands;
  2103.   var i:integer;
  2104.   begin
  2105.     if not sponsoron then begin
  2106.       reqlevel (sysoplevel);
  2107.       exit
  2108.  
  2109.  
  2110.     end;
  2111.     writelog (15,3,area.name);
  2112.     repeat
  2113.       i:=menu ('File Transfer Sponsor','FSYSOP','A@CDF@G@KRNSMLO@QEW*@V?');{P}
  2114.       case i of
  2115.         1:sysopadd;
  2116.         2:changef;
  2117.         3:deletef;
  2118.         4:directory;
  2119.         5:offfaq;
  2120.         6:killarea;
  2121.         7:modarea;
  2122.         8:newfiles;
  2123.         9:sortarea;
  2124.         10:movefile;
  2125.         11:listxmodem;
  2126.         12:reorderareas;
  2127.         14:renamefile;
  2128.         15:addmultiplefiles;
  2129.         16:getarea;
  2130.         17:renameallfiles;
  2131.         18:begin
  2132.            sponsormenu;
  2133.            end;
  2134.       end
  2135.     until hungupon or (i=13)
  2136.   end;
  2137.  
  2138.   procedure listfile (n:integer; extended:boolean);
  2139.   var ud       :udrec;
  2140.       q,xy     :sstr;
  2141.       a        :string;
  2142.       b        :string;
  2143.       c        :string;
  2144.       ed       :string;
  2145.       desc     :string;
  2146.       lamedata :string[1];
  2147.       up1      :byte;
  2148.       dah      :boolean;
  2149.   begin
  2150.     seekudfile (n);
  2151.     read (udfile,ud);
  2152.     write (^S+strr(n));
  2153.     spacelen(4-length(strr(n)));
  2154.     if ffname in urec.filelister then begin
  2155.     write(^S+UPSTRING(copy(ud.filename,1,length(ud.filename)-4)));
  2156.     spacelen(9-length(copy(ud.filename,1,length(ud.filename)-4)));
  2157.     end;
  2158.     if ffext in urec.filelister then begin
  2159.     write(^S+upstring(copy(ud.filename,length(ud.filename)-2,3)));
  2160.     spacelen(4-length(copy(ud.filename,length(ud.filename)-2,3)));
  2161.     end;
  2162.     if ffsize in urec.filelister then begin
  2163.     if exist (getfname(ud.path,ud.filename)) then begin
  2164.     write(^S,strlong(ud.filesize));
  2165.     spacelen(10-length(strlong(ud.filesize)));
  2166.     end;
  2167.     if not exist (getfname(ud.path,ud.filename)) then begin
  2168.      write (^P'['^S'Offline'^P'] '^S);
  2169.     end;
  2170.    end;
  2171.     if ffpoints in urec.filelister then begin
  2172.     if ud.newfile
  2173.           then write (^S'New  ')
  2174.           else if length(ud.private)>0
  2175.             then write (^S'Priv ')
  2176.             else if ud.specialfile
  2177.               then write (^S'Ask  ')
  2178.               else if ud.points>0
  2179.                 then begin write (^S+strr(ud.points)); spacelen (5-length(strr(ud.points))) end
  2180.                   else if leechweek
  2181.                   then write (^S'N/A  ')
  2182.                     else write (^S'Free ')
  2183.     end;
  2184.     if ffuploader in urec.filelister then begin
  2185.     write(^S,ud.sentby);
  2186.     spacelen(13-length(ud.sentby));
  2187.     end;
  2188.     if ffuploaded in urec.filelister then begin
  2189.     write(^S,datestr(ud.when));
  2190.     spacelen(9-length(datestr(ud.when)));
  2191.     end;
  2192.     if ffdown in urec.filelister then begin
  2193.     write(^S,strr(ud.downloaded));
  2194.     spacelen(4-length(strr(ud.downloaded)));
  2195.     end;
  2196.     if fffulnam in urec.filelister then begin
  2197.     write (^S,ud.programname);
  2198.     spacelen(28-length(ud.programname));
  2199.     end;
  2200.     if ffofwhat in urec.filelister then begin
  2201.     xy:=^S+strr(ud.disknum)+^R'/'^S+strr(ud.totaldisk);
  2202.     write (^S,xy);
  2203.     spacelen(6-length(xy));
  2204.     end;
  2205.     writeln;
  2206.  if cn>18 then cn:=18;
  2207.   {end;}
  2208.  end;
  2209.  
  2210.   function nofiles:boolean;
  2211.   begin
  2212.     if numuds=0 then begin
  2213.       nofiles:=true;
  2214.       writestr (^M'Sorry, no files!')
  2215.     end else nofiles:=false;
  2216.   end;
  2217.  
  2218.   Function capfir(inString:STRING):STRING;
  2219.  begin
  2220.    capfir:=upcase(inString[1]);
  2221.  end;
  2222.  
  2223.   procedure listfiles (extended:boolean);
  2224.   var cnt,max,r1,r2:integer;
  2225.       non:boolean;
  2226.   begin
  2227.     if nofiles then exit;
  2228.     clearscr;
  2229.     cn:=0;
  2230.     non:=false;
  2231.     max:=numuds;
  2232.     thereare (max,'File','Files');
  2233.     parserange (max,r1,r2);
  2234.     if r1=0 then exit;
  2235.    {writeln;}
  2236.    topfileline;
  2237.     for cnt:=r1 to r2 do begin
  2238.      inc(cn);
  2239.        if (cn>=18) and (non=false) then
  2240.      begin
  2241.       bottomfileline;
  2242.       cn:=0;
  2243.       writestr (^S'CR'^P'/'^R'Next  '^S'+'^P'/'^R'Add to batch  '^S'D'^R'ownload  '^S'N'^R'on-stop  '^S
  2244.       +'Q'^R'uit  '^S'V'^R'iew'^P': '^U'*');
  2245.       if capfir(input)='A' then addtobatch (0);
  2246.       if capfir(input)='D' then download (0,true);
  2247.       if capfir(input)='N' then non:=true;
  2248.       if capfir(input)='Q' then exit;
  2249.       if capfir(input)='V' then listarchive (0);
  2250.       topfileline;
  2251.      end;
  2252.       listfile (cnt,extended);
  2253.       if break then exit
  2254.     end;
  2255.   bottomfileline;
  2256.   end;
  2257.  
  2258. var i,c,kkk1,kkk2,oldarea:integer;
  2259.     a:arearec;
  2260.     ms:boolean;
  2261.     z:integer;
  2262.     x1,x2,x3:integer;
  2263.     y1,y2,y3:real;
  2264.     xferlist:text;
  2265.     temp:file;
  2266. label ok,exit2;
  2267. begin
  2268.   urec.averagecps:=baudrate div 10;
  2269.   vcr:=false;
  2270.   cursection:=udsysop;
  2271.   ms:=false;
  2272.   if (x3<xferpcr) and (ulvl<pcrexempt) then begin
  2273.   writeln ('File Access Denied!');
  2274.   writeln ('Your PCR is lower than the required PCR in the setup.');
  2275.   goto exit2; end;
  2276.   writehdr ('File Transfer Section');
  2277.   input:='';
  2278.   if exist ('BATCH.'+strr(conn)) then begin
  2279.    assign (temp,datadir+'BATCH.'+strr(conn));
  2280.    erase (temp);
  2281.   end;
  2282.   assign (batfile,datadir+'BATCH.'+strr(conn));
  2283.   close (batfile);
  2284.   reset (batfile);
  2285.   if ioresult<>0 then rewrite (batfile);
  2286.   assign (afile,datadir+'Areadir'+'.'+strr(conn));
  2287.   if exist (datadir+'Areadir'+'.'+strr(conn)) then
  2288.       begin
  2289.         reset (afile);
  2290.         if filesize (afile)>0 then goto ok
  2291.       end
  2292.     else rewrite (afile);
  2293.   getconpw;
  2294.   writeln ('No transfer areas exist!');
  2295.   area.xmodemdir:=faqdir+'XFER\';
  2296.   if issysop
  2297.     then if makearea
  2298.       then goto ok;
  2299.   goto exit2;
  2300.   ok:
  2301.   seekafile (1);
  2302.   read (afile,a);
  2303.   if urec.udlevel<a.level then begin
  2304.     writeln ('Sorry, you can''t access the first area!');
  2305.     goto exit2
  2306.   end;
  2307.   writeln;
  2308.   if exist(textfiledir+'FILENEWS.'+strr(conn)) then begin
  2309.   printfile (textfiledir+'FILENEWS.'+strr(conn));
  2310.   pause;
  2311.   end;
  2312.   x3:=percent(urec.nbu,urec.numon);
  2313.   yourudstats;
  2314.   setarea(1);
  2315.   repeat
  2316.     if withintime (xmodemclosetime,xmodemopentime) then
  2317.       if not issysop then begin
  2318.       printxy(42,12,^S+'Transfer section closed.'+^R);
  2319.         goto exit2
  2320.       end else if not ms then begin
  2321.         ms:=true
  2322.       end;
  2323.       write (^B);
  2324.       writeln (^R'Conference #'^S+strr(conn)+' '+area.name+^P' ['^S+strr(curarea)+^P']');
  2325.     if sponsoron or issysop
  2326.       then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
  2327.     oldarea:=curarea;
  2328.     i:=menu ('File Transfer','FILE','UDLWYA*SQ%NVRFXTEGB+ZJ?');
  2329.     if hungupon then goto exit2;
  2330.     case i of
  2331.       1:upload;
  2332.       2:download (0,true);
  2333.       3:listfiles (false);
  2334.       4:sendmailto (area.sponsor,false);
  2335.       5:yourudstats;
  2336.       6,7:getarea;
  2337.       8:begin;
  2338.         searchfile;
  2339.         setarea(oldarea);
  2340.     end;
  2341.       10:sysopcommands;
  2342.  
  2343.       11:begin;
  2344.         newscanall;
  2345.         setarea(oldarea);
  2346.      end;
  2347.       12:begin;
  2348.         newscan;
  2349.         setarea(oldarea);
  2350.      end;
  2351.       13:listarchive (0);
  2352.       14:{whoup;}configurefilelisting;
  2353.       15:xtendedlist;
  2354.       16:typefile;
  2355.       17:requestfile;
  2356.       18:generatelist;
  2357.       19:batchmenu;
  2358.       20:addtobatch (0);
  2359.       21:extractfile;
  2360.       22:begin changecon('X'); close (afile); close (udfile); close (batfile); i:=ioresult;
  2361.       erase (batfile); assign (xferlist,textfiledir+'Xferlist.FAQ');
  2362.   if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist); udsection; exit; end;
  2363.       23:begin
  2364.          xfermenu;
  2365.          end;
  2366.     end
  2367.   until hungupon or (i=9);
  2368.   exit2:
  2369.   close (afile);
  2370.   close (udfile);
  2371.   close (batfile);
  2372.   i:=ioresult;
  2373.   erase (batfile);
  2374.   assign (xferlist,textfiledir+'Xferlist.FAQ');
  2375.   if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist);
  2376. end;
  2377.  
  2378. begin
  2379. end.